home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 January / ChipCD_1.03.iso / zkuste / delphi / kolekce / d3456 / GmPrintSuite_2_61_Lite.exe / {app} / GmPrinter.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-10-10  |  48.2 KB  |  1,632 lines
  1. {******************************************************************************}
  2. {                                                                              }
  3. {                          GmPrinter.pas v2.61 Lite                            }
  4. {                                                                              }
  5. {           Copyright (c) 2001 Graham Murt  - www.MurtSoft.co.uk               }
  6. {                                                                              }
  7. {   Feel free to e-mail me with any comments, suggestions, bugs or help at:    }
  8. {                                                                              }
  9. {                           graham@murtsoft.co.uk                              }
  10. {                                                                              }
  11. {******************************************************************************}
  12.  
  13. unit GmPrinter;
  14.  
  15. interface
  16.  
  17. uses Windows, Classes, Printers, Graphics, Messages, JPeg, GmTypes, Dialogs;
  18.  
  19. {$I GMPS.INC}
  20.  
  21. type
  22.   TGmPrinterCanvas = class
  23.   private
  24.     FActive: Boolean;
  25.     FCopyMode: TCopyMode;
  26.     FFontAngle: Extended;
  27.     FHFont: HFONT;
  28.     FHPen: HPEN;
  29.     FOffset: TPoint;
  30.     FPenPos: TGmPoint;
  31.     FPpiX: integer;
  32.     FPpiY: integer;
  33.     FPrintColor: TGmPrintColor;
  34.     FPrinterCanvas: TCanvas;
  35.     FPrintScale: Extended;
  36.     FSaveBrush: TBrush;
  37.     function GetBrush: TBrush;
  38.     function GetFont: TFont;
  39.     function GetHandle: THandle;
  40.     function GetPen: TPen;
  41.     function GraphicExtent(AGraphic: TGraphic): TGmSize;
  42.     function TextExtent(AText: string): TGmSize;
  43.     procedure DeleteFont;
  44.     procedure DeletePen;
  45.     procedure PrintBitmap(ARect: TGmRect; Bitmap: TBitmap);
  46.     procedure PrintJpeg(ARect: TGmRect; JPeg: TJPegImage);
  47.     procedure PrintMetafile(ARect: TGmRect; AMetafile: TMetafile);
  48.     procedure PrintPolyShape(AShapeID: integer; const inchPoints: array of TGmPoint);
  49.     procedure SelectFont(AScale: Extended);
  50.     procedure SelectPen;
  51.     procedure SetActive(AValue: Boolean);
  52.   protected
  53.     property PpiX: integer read FPpiX;
  54.     property PpiY: integer read FPpiY;
  55.   public
  56.     constructor Create;
  57.     destructor Destroy; override;
  58.     function GraphicHeightInch(AGraphic: TGraphic): Extended;
  59.     function GraphicWidthInch(AGraphic: TGraphic): Extended;
  60.     function TextHeight(AText: string): integer;
  61.     function TextWidth(AText: string): integer;
  62.     function TextHeightInch(AText: string): Extended;
  63.     function TextWidthInch(AText: string): Extended;
  64.     procedure Arc(inchPoints: TGmComplexPoints);
  65.     procedure Chord(inchPoints: TGmComplexPoints);
  66.     procedure Draw(inchX, inchY: Extended; AGraphic: TGraphic);
  67.     procedure Ellipse(inchX, inchY, inchX2, inchY2: Extended);
  68.     procedure MoveTo(inchX, inchY: Extended);
  69.     procedure LineTo(inchX, inchY: Extended);
  70.     procedure Pie(inchPoints: TGmComplexPoints);
  71.     procedure Polygon(const inchPoints: array of TGmPoint);
  72.     procedure Polyline(const inchPoints: array of TGmPoint);
  73.     procedure PolylineTo(const inchPoints: array of TGmPoint);
  74.     procedure PolyBezier(const inchPoints: array of TGmPoint);
  75.     procedure PolyBezierTo(const inchPoints: array of TGmPoint);
  76.     procedure Rectangle(inchX, inchY, inchX2, inchY2: Extended);
  77.     procedure Refresh;
  78.     procedure RoundRect(inchX, inchY, inchX2, inchY2, inchCornerX, inchCornerY: Extended);
  79.     procedure StretchDraw(inchRect: TGmRect; AGraphic: TGraphic);
  80.     procedure TextBoxOut(inchRect: TGmRect; Align: TAlignment; VertAlign: TGmVertAlignment; AWordBreak: Byte; AText: string);
  81.     procedure TextOut(inchX, inchY: Extended; Alignment: TAlignment; AText: string);
  82.     procedure TextOutRotate(inchX, inchY, Angle: Extended; AText: string);
  83.     // path functions...
  84.     procedure BeginPath;
  85.     procedure EndPath;
  86.     procedure StrokePath;
  87.     procedure FillPath;
  88.     procedure StrokeAndFillPath;
  89.     procedure CloseFigure;
  90.     // properties...
  91.     property Canvas: TCanvas read FPrinterCanvas;
  92.     property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy;
  93.     property Handle: THandle read GetHandle;
  94.     property Brush: TBrush read GetBrush;
  95.     property Font: TFont read GetFont;
  96.     property FontAngle: Extended read FFontAngle write FFontAngle;
  97.     property PenPos: TGmPoint read FPenPos;
  98.     property Pen: TPen read GetPen;
  99.   end;
  100.  
  101.   TGmPrinter = class(TGmCustomPrinter)
  102.   private
  103.     FAvailableWidth: Extended;
  104.     FAvailableHeight: Extended;
  105.     FCanvas: TGmPrinterCanvas;
  106.     FDevice, FDriver, FPort: array[0..80] of Char;
  107.     FDitherType: TGmDitherType;
  108.     FDuplexType: TGmDuplexType;
  109.     FFileName: string;
  110.     FOffset: TPoint;
  111.     FOrientation: TPrinterOrientation;
  112.     FOrientationSwapped: Boolean;
  113.     FPageCount: integer;
  114.     FPageHeight: Extended;
  115.     FPageWidth: Extended;
  116.     FPagesPerSheet: TGmPagesPerSheet;
  117.     FPpiX: integer;
  118.     FPpiY: integer;
  119.     FPrintColor: TGmPrintColor;
  120.     FPrintCopies: integer;
  121.     FPrintDialog: TPrintDialog;
  122.     FPrinterBins: TStrings;
  123.     FPrinters: TStrings;
  124.     FPrinting: Boolean;
  125.     FPrintQuality: TGmPrintQuality;
  126.     FReversePrintOrder: Boolean;
  127.     FShowPrintDialog: Boolean;
  128.     FTempValue: TGmValue;
  129.     FTempValueRect: TGmValueRect;
  130.     FTitle: string;
  131.     DeviceMode: THandle;
  132.     DevMode: PDeviceMode;
  133.     // events...
  134.     FOnPrinterChanged: TNotifyEvent;
  135.     function GetAborted: Boolean;
  136.     function GetAvailableHeight: integer;
  137.     function GetAvailableHeightGmValue: TGmValue;
  138.     function GetAvailableWidth: integer;
  139.     function GetAvailableWidthGmValue: TGmValue;
  140.     function GetGmValue: TGmValue;
  141.     function GetGmValueRect: TGmValueRect;
  142.     function GetHandle: THandle;
  143.     function GetIndexOf(const APrinter: string): integer;
  144.     function GetIsColorPrinter: Boolean;
  145.     function GetMarginsInch: TGmRect;
  146.     function GetOffset: TPoint;
  147.     function GetPixelOffsetX: integer;
  148.     function GetPixelOffsetY: integer;
  149.     function GetOffsetInchXY: TGmPoint;
  150.     function GetOrientation: TPrinterOrientation;
  151.     function GetPageHeight: integer;
  152.     function GetPageWidth: integer;
  153.     function GetPageHeightGmValue: TGmValue;
  154.     function GetPageWidthGmValue: TGmValue;
  155.     //function GetPageHeightInch: Extended;
  156.     //function GetPageWidthInch: Extended;
  157.     function GetPaperSize: TGmPaperSize;
  158.     function GetPpiX: integer;
  159.     function GetPpiY: integer;
  160.     function GetPrinterBinIndex: integer;
  161.     function GetPrinterBins: TStrings;
  162.     function GetPrinterIndex: integer;
  163.     function GetPrinterMargins: TGmValueRect;
  164.     function GetPrinters: TStrings;
  165.     function GetPrinterSelected: Boolean;
  166.     procedure PrintToFile(AFileName: string);
  167.     procedure LockPrinter;
  168.     procedure OffsetCanvas;
  169.     //procedure ReloadDevMode;
  170.     procedure ResetPrinter;
  171.     procedure SetDitherType(const AValue: TGmDitherType);
  172.     procedure SetDuplexType(const AValue: TGmDuplexType);
  173.     procedure SetOrientation(AOrientation: TPrinterOrientation);
  174.     procedure SetPaperSize(APaperSize: TGmPaperSize);
  175.     procedure SetPrintColor(AColor: TGmPrintColor);
  176.     procedure SetPrintDialog(const ADialog: TPrintDialog);
  177.     procedure SetPrinterBinIndex(const AValue: integer);
  178.     procedure SetPrinterIndex(const AValue: integer);
  179.     procedure SetPrintQuality(const AValue: TGmPrintQuality);
  180.     procedure SetTitle(const ATitle: string);
  181.     procedure SwapOrientation;
  182.     procedure UnlockPrinter;
  183.     // event procedures...
  184.     procedure PrinterChanged(Sender: TObject);
  185.   public
  186.     constructor Create;
  187.     destructor Destroy; override;
  188.     procedure Abort;
  189.     procedure Assign(Source: TPersistent); override;
  190.     procedure BeginDoc;
  191.     procedure EndDoc;
  192.     procedure NewPage(AOrientation: TGmOrientation);
  193.     procedure RefreshPrinters;
  194.     property Aborted: Boolean read GetAborted;
  195.     property AvailableHeight: TGmValue read GetAvailableHeightGmValue;
  196.     property AvailableWidth: TGmValue read GetAvailableWidthGmValue;
  197.     property Canvas: TGmPrinterCanvas read FCanvas;
  198.     property FileName: string read FFileName write FFileName;
  199.     property Handle: THandle read GetHandle;
  200.     property IndexOf[const Printer: string]: integer read GetIndexOf;
  201.     property IsColorPrinter: Boolean read GetIsColorPrinter;
  202.     property Orientation: TPrinterOrientation read GetOrientation write SetOrientation;
  203.     property PagesPerSheet: TGmPagesPerSheet read FPagesPerSheet write FPagesPerSheet default gmOnePage;
  204.     property Printing: Boolean read FPrinting;
  205.     property Offset: TPoint read GetOffset;
  206.     property PrinterBinIndex: integer read GetPrinterBinIndex write SetPrinterBinIndex;
  207.     property PrinterBins: TStrings read GetPrinterBins;
  208.     property PrinterMargins: TGmValueRect read GetPrinterMargins;
  209.     property PrinterPaperSize: TGmPaperSize read GetPaperSize write SetPaperSize;
  210.     property PrinterHeight: TGmValue read GetPageHeightGmValue;
  211.     property PrinterIndex: integer read GetPrinterIndex write SetPrinterIndex;
  212.     property Printers: TStrings read GetPrinters;
  213.     property PrinterSelected: Boolean read GetPrinterSelected;
  214.     property PrinterWidth: TGmValue read GetPageWidthGmValue;
  215.     property PrinterPpiX: integer read GetPpiX;
  216.     property PrinterPpiY: integer read GetPpiY;
  217.     property OnPrinterChanged: TNotifyEvent read FOnPrinterChanged write FOnPrinterChanged;
  218.   published
  219.     property PrintColor: TGmPrintColor read FPrintColor write FPrintColor stored True default gmColor;
  220.     property PrintCopies: integer read FPrintCopies write FPrintCopies default 1;
  221.     property DitherType: TGmDitherType read FDitherType write FDitherType default gmGrayScale;
  222.     property Duplex: TGmDuplexType read FDuplexType write FDuplexType default gmSimplex;
  223.     property PrintDialog: TPrintDialog read FPrintDialog write SetPrintDialog;
  224.     property PrintQuality: TGmPrintQuality read FPrintQuality write FPrintQuality default gmMedium;
  225.     property ReversePrintOrder: Boolean read FReversePrintOrder write FReversePrintOrder default True;
  226.     property ShowPrintDialog: Boolean read FShowPrintDialog write FShowPrintDialog default True;
  227.     property Title: string read FTitle write SetTitle;
  228.   end;
  229.  
  230.   function AsGmOrientation(AOrientation: TPrinterOrientation): TGmOrientation;
  231.   function AsPrinterOrientation(AOrientation: TGmOrientation): TPrinterOrientation;
  232.   function AsGmPaperSize(APaperSize: SmallInt): TGmPaperSize;
  233.   function AsPrinterPaperSize(APaperSize: TGmPaperSize): SmallInt;
  234.   function ConvertPenStyle(APenStyle: TPenStyle): Byte;
  235.   function PrinterPpiX: Extended;
  236.   function PrinterPpiY: Extended;
  237.  
  238.  
  239. implementation
  240.  
  241. uses GmConst, Math, SysUtils, WinSpool;
  242.  
  243. //------------------------------------------------------------------------------
  244.  
  245. // *** Global functions ***
  246.  
  247. function AsGmOrientation(AOrientation: TPrinterOrientation): TGmOrientation;
  248. begin
  249.   if AOrientation = poPortrait then
  250.     Result := gmPortrait
  251.   else
  252.     Result := gmLandscape;
  253. end;
  254.  
  255. function AsPrinterOrientation(AOrientation: TGmOrientation): TPrinterOrientation;
  256. begin
  257.   if AOrientation = gmPortrait then
  258.     Result := poPortrait
  259.   else
  260.     Result := poLandscape;
  261. end;
  262.  
  263. function AsGmPaperSize(APaperSize: SmallInt): TGmPaperSize;
  264. begin
  265.   case APaperSize of
  266.     DMPAPER_LETTER  : Result := Letter;
  267.     DMPAPER_LEGAL   : Result := Legal;
  268.     DMPAPER_A3      : Result := A3;
  269.     DMPAPER_A4      : Result := A4;
  270.     DMPAPER_A5      : Result := A5;
  271.     DMPAPER_A6      : Result := A6;
  272.     DMPAPER_B5      : Result := B5;
  273.     DMPAPER_ENV_C5  : Result := C5;
  274.   else
  275.     Result := Custom;
  276.   end
  277. end;
  278.  
  279. function AsPrinterPaperSize(APaperSize: TGmPaperSize): SmallInt;
  280. begin
  281.   Result := -1;
  282.   case APaperSize of
  283.     A3    : Result := DMPAPER_A3;
  284.     A4    : Result := DMPAPER_A4;
  285.     A5    : Result := DMPAPER_A5;
  286.     A6    : Result := DMPAPER_A6;
  287.     B5    : Result := DMPAPER_B5;
  288.     C5    : Result := DMPAPER_ENV_C5;
  289.     Legal : Result := DMPAPER_LEGAL;
  290.     Letter: Result := DMPAPER_LETTER;
  291.   end;
  292. end;
  293.  
  294. function ConvertPenStyle(APenStyle: TPenStyle): Byte;
  295. begin
  296.  Result := 0;
  297.   case APenStyle of
  298.        psSolid:             Result := PS_SOLID;
  299.     psDash:              Result := PS_DASH;
  300.       psDot:                 Result := PS_DOT;
  301.        psDashDot:        Result := PS_DASHDOT;
  302.     psDashDotDot:    Result := PS_DASHDOTDOT;
  303.     psClear:            Result := PS_NULL;
  304.   end;
  305. end;
  306.  
  307. function PrinterPpiX: Extended;
  308. begin
  309.   if Printer.Printers.Count > 0 then
  310.     Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)
  311.   else
  312.     Result := DEFAULT_DRAW_DPI;
  313. end;
  314.  
  315. function PrinterPpiY: Extended;
  316. begin
  317.   if Printer.Printers.Count > 0 then
  318.     Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)
  319.   else
  320.     Result := DEFAULT_DRAW_DPI;
  321. end;
  322.  
  323. // *** Local functions ***
  324.  
  325. function InchesToPixels(AValue: Extended; Ppi: integer): integer;
  326. begin
  327.   Result := Round(AValue * Ppi);
  328. end;
  329.  
  330. function GmPointToPixels(APoint: TGmPoint; PpiX, PpiY: integer): TPoint;
  331. begin
  332.   Result.x := InchesToPixels(APoint.x, PpiX);
  333.   Result.y := InchesToPixels(APoint.y, PpiY);
  334. end;
  335.  
  336. function GmRectToPixels(ARect: TGmRect; PpiX, PpiY: integer): TRect;
  337. begin
  338.   Result.Left     := InchesToPixels(ARect.Left, PpiX);
  339.   Result.Top      := InchesToPixels(ARect.Top, PpiY);
  340.   Result.Right    := InchesToPixels(ARect.Right, PpiX);
  341.   Result.Bottom   := InchesToPixels(ARect.Bottom, PpiY);
  342. end;
  343.  
  344. function PixelsToInches(AValue: Integer; Ppi: integer): Extended;
  345. begin
  346.   Result := AValue / Ppi;
  347. end;
  348.  
  349. function ScaleValue(AValue, AScale: Extended): Extended;
  350. begin
  351.   Result := AValue * AScale;
  352. end;
  353.  
  354. function ScaleGmPoint(APoint: TGmPoint; AScale: Extended): TGmPoint;
  355. begin
  356.   Result.x := APoint.x * AScale;
  357.   Result.y := APoint.y * AScale;
  358. end;
  359.  
  360. function ScaleGmRect(ARect: TGmRect; AScale: Extended): TGmRect;
  361. begin
  362.   Result.Left   := ScaleValue(ARect.Left, AScale);
  363.   Result.Top    := ScaleValue(ARect.Top, AScale);
  364.   Result.Right  := ScaleValue(ARect.Right, AScale);
  365.   Result.Bottom := ScaleValue(ARect.Bottom, AScale);
  366. end;
  367.  
  368. //------------------------------------------------------------------------------
  369.  
  370. {$IFDEF D4+}
  371.  
  372. // *** Polygon object printing routines ***
  373.  
  374. type
  375.   PPoints = ^TPoints;
  376.   TPoints = array[0..0] of TPoint;
  377.  
  378. procedure PrintPolygon(ACanvas: TCanvas; const Points: array of TPoint);
  379. begin
  380.   Windows.Polygon(ACanvas.Handle, PPoints(@Points)^, High(Points) + 1);
  381. end;
  382.  
  383. procedure PrintPolyline(ACanvas: TCanvas; const Points: array of TPoint);
  384. begin
  385.   Windows.Polyline(ACanvas.Handle, PPoints(@Points)^, High(Points) + 1);
  386. end;
  387.  
  388. procedure PrintPolylineTo(ACanvas: TCanvas; const Points: array of TPoint);
  389. begin
  390.   Windows.PolylineTo(ACanvas.Handle, PPoints(@Points)^, High(Points) + 1);
  391. end;
  392.  
  393. procedure PrintPolyBezier(ACanvas: TCanvas; const Points: array of TPoint);
  394. begin
  395.   Windows.PolyBezier(ACanvas.Handle, PPoints(@Points)^, High(Points) + 1);
  396. end;
  397.  
  398. procedure PrintPolyBezierTo(ACanvas: TCanvas; const Points: array of TPoint);
  399. begin
  400.   Windows.PolyBezierTo(ACanvas.Handle, PPoints(@Points)^, High(Points) + 1);
  401. end;
  402.  
  403. {$ENDIF}
  404.  
  405. //------------------------------------------------------------------------------
  406.  
  407. // *** TGmPrinterCanvas ***
  408.  
  409. constructor TGmPrinterCanvas.Create;
  410. begin
  411.   inherited Create;
  412.   FSaveBrush := TBrush.Create;
  413.   FFontAngle := 0;
  414.   FHPen := 0;
  415.   FPenPos := GmPoint(0,0);
  416.   FCopyMode := cmSrcCopy;
  417.   FPrintScale := 0.5;
  418. end;
  419.  
  420. destructor TGmPrinterCanvas.Destroy;
  421. begin
  422.   DeleteFont;
  423.   DeletePen;
  424.   FSaveBrush.Free;
  425.   inherited Destroy;
  426. end;
  427.  
  428. //------------------------------------------------------------------------------
  429.  
  430. // *** Private functions ***
  431.  
  432. function TGmPrinterCanvas.GetBrush: TBrush;
  433. begin
  434.   Result := FPrinterCanvas.Brush;
  435. end;
  436.  
  437. function TGmPrinterCanvas.GetFont: TFont;
  438. begin
  439.   Result := FPrinterCanvas.Font;
  440. end;
  441.  
  442. function TGmPrinterCanvas.GetHandle: THandle;
  443. begin
  444.   Result := FPrinterCanvas.Handle;
  445. end;
  446.  
  447. function TGmPrinterCanvas.GetPen: TPen;
  448. begin
  449.   Result := FPrinterCanvas.Pen;
  450. end;
  451.  
  452. function TGmPrinterCanvas.GraphicExtent(AGraphic: TGraphic): TGmSize;
  453. begin
  454.   Result.Height := PixelsToInches(AGraphic.Height, PpiY);
  455.   Result.Width  := PixelsToInches(AGraphic.Width, PpiX);
  456. end;
  457.  
  458. function TGmPrinterCanvas.TextExtent(AText: string): TGmSize;
  459. begin
  460.   Result.Height := PixelsToInches(Canvas.TextHeight(AText), PpiY);
  461.   Result.Width  := PixelsToInches(Canvas.TextWidth(AText), PpiX);
  462. end;
  463.  
  464. procedure TGmPrinterCanvas.DeleteFont;
  465. begin
  466.   if FHFont <> 0 then DeleteObject(FHFont);
  467. end;
  468.  
  469. procedure TGmPrinterCanvas.DeletePen;
  470. begin
  471.   if FHPen <> 0 then DeleteObject(FHPen);
  472. end;
  473.  
  474. procedure TGmPrinterCanvas.PrintBitmap(ARect: TGmRect; Bitmap: TBitmap);
  475. var
  476.   BitmapHeader: pBitmapInfo;
  477.   BitmapImage : POINTER;
  478.   HeaderSize : DWORD; // Use DWORD for D3-D5 compatibility
  479.   ImageSize : DWORD;
  480.   CM : LongInt;
  481.   DestRect: TRect;
  482. begin
  483.   DestRect := GmRectToPixels(ScaleGmRect(ARect, FPrintScale), PpiX, PpiY);
  484.   CM := SRCCOPY;
  485.   case FCopyMode of
  486.     cmBlackness:  CM := BLACKNESS;
  487.     cmDstInvert:  CM := DSTINVERT;
  488.     cmMergeCopy:  CM := MERGECOPY;
  489.     cmMergePaint: CM := MERGEPAINT;
  490.     cmNotSrcCopy: CM := NOTSRCCOPY;
  491.     cmNotSrcErase:CM := NOTSRCERASE;
  492.     cmPatCopy:    CM := PATCOPY;
  493.     cmPatInvert:  CM := PATINVERT;
  494.     cmPatPaint:   CM := PATPAINT;
  495.     cmSrcAnd:     CM := SRCAND;
  496.     cmSrcCopy:    CM := SRCCOPY;
  497.     cmSrcErase:   CM := SRCERASE;
  498.     cmSrcInvert:  CM := SRCINVERT;
  499.     cmSrcPaint:   CM := SRCPAINT;
  500.     cmWhiteness:  CM := WHITENESS;
  501.   end;
  502.   GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
  503.   GetMem(BitmapHeader, HeaderSize);
  504.   GetMem(BitmapImage, ImageSize);
  505.   GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
  506.   try
  507.     StretchDIBits(Handle,
  508.                   DestRect.Left, DestRect.Top,    // Destination Origin
  509.                   DestRect.Right - DestRect.Left, // Destination Width
  510.                   DestRect.Bottom - DestRect.Top, // Destination Height
  511.                   0, 0,                           // Source Origin
  512.                   Bitmap.Width, Bitmap.Height,    // Source Width & Height
  513.                   BitmapImage,
  514.                   TBitmapInfo(BitmapHeader^),
  515.                   DIB_RGB_COLORS,
  516.                   CM);
  517.   finally
  518.     FreeMem(BitmapHeader);
  519.     FreeMem(BitmapImage)
  520.   end;
  521. end;
  522.  
  523. procedure TGmPrinterCanvas.PrintJpeg(ARect: TGmRect; JPeg: TJPegImage);
  524. var
  525.   ABitmap: TBitmap;
  526. begin
  527.   ABitmap := TBitmap.Create;
  528.   try
  529.     ABitmap.PixelFormat := pf24Bit;
  530.     ABitmap.Height := JPeg.Height;
  531.     ABitmap.Width := JPeg.Width;
  532.     ABitmap.Canvas.Draw(0, 0, JPeg);
  533.     PrintBitmap(ARect, ABitmap);
  534.   finally
  535.     ABitmap.Free;
  536.   end;
  537. end;
  538.  
  539. procedure TGmPrinterCanvas.PrintMetafile(ARect: TGmRect; AMetafile: TMetafile);
  540. var
  541.   DestRect: TRect;
  542. begin
  543.   DestRect := GmRectToPixels(ARect, PpiX, PpiY);
  544.   //Canvas.stretchDraw(DestRect, AMetafile);
  545.   PlayEnhMetaFile(Handle, AMetafile.Handle, DestRect);
  546. end;
  547.  
  548. procedure TGmPrinterCanvas.PrintPolyShape(AShapeID: integer; const inchPoints: array of TGmPoint);
  549. {$IFDEF D4+}
  550. var
  551.   NewPoints: array of TPoint;
  552.   ICount: integer;
  553. {$ENDIF}
  554. begin
  555.     {$IFDEF D4+}
  556.   if not FActive then Exit;
  557.   SelectPen;
  558.   SetLength(NewPoints, High(inchPoints)+1);
  559.   for ICount := 0 to High(inchPoints) do
  560.     NewPoints[ICount] := GmPointToPixels(ScaleGmPoint(inchPoints[ICount], FPrintScale), PpiX, PpiY);
  561.  
  562.   case AShapeID of
  563.     GM_POLYGON_ID     : PrintPolygon(Canvas, NewPoints);
  564.     GM_POLYLINE_ID    : PrintPolyline(Canvas, NewPoints);
  565.     GM_POLYBEZIER_ID  : PrintPolyBezier(Canvas, NewPoints);
  566.     GM_POLYLINETO_ID  : PrintPolylineTo(Canvas, NewPoints);
  567.     GM_POLYBEZIERTO_ID: PrintPolyBezierTo(Canvas, NewPoints);
  568.   end;
  569.   {$ENDIF}
  570. end;
  571.  
  572. procedure TGmPrinterCanvas.SelectFont(AScale: Extended);
  573. var
  574.   lf: TLogFont;
  575.   //AFont: TFont;
  576. begin
  577.   //DeleteFont;
  578.  
  579.   //AFont := TFont.Create;
  580.     //AFont.Assign(Canvas.Font);
  581.  
  582.   //GetObject(AFont.Handle, sizeof(lf), @lf);
  583.   GetObject(Canvas.Font.Handle, sizeof(lf), @lf);
  584.   lf.lfEscapement := Round(FFontAngle * 10);
  585.   lf.lfOrientation := Round(FFontAngle * 10);
  586.   if fsBold in Canvas.Font.Style then lf.lfWeight := FW_ULTRABOLD;
  587.   if fsItalic in Canvas.Font.Style then lf.lfItalic := Integer(True);
  588.   if fsUnderline in Canvas.Font.Style then lf.lfUnderline := Integer(True);
  589.   lf.lfHeight := Round(lf.lfHeight * AScale);
  590.   //lf.
  591.   //AFont.Handle := CreateFontIndirect(lf);
  592.   FHFont := CreateFontIndirect(lf);
  593.  
  594.   SelectObject(Canvas.Handle, FHFont);
  595.   //SelectObject(Canvas.Handle, AFont.Handle);
  596.   //Canvas.Font.Assign(AFont);
  597. //  AFont.Free;
  598. end;
  599.  
  600. procedure TGmPrinterCanvas.SelectPen;
  601. var
  602.   LB: TLogBrush;
  603.   APenStyle: Byte;
  604.   APenWidth: integer;
  605.   OnePt: Extended;
  606. begin
  607.   if (Canvas.Pen.Width * FPrintScale) <= 1 then
  608.   begin
  609.     Canvas.Pen.Width := 1;
  610.     Exit;
  611.   end;
  612.   OnePt := (PpiY / 72);
  613.   LB.lbColor := Pen.Color;
  614.   LB.lbStyle := BS_SOLID;
  615.   LB.lbHatch := 0;
  616.   APenStyle := ConvertPenStyle(Pen.Style);
  617.   APenWidth := Round(((Pen.Width * OnePt)/4) * FPrintScale);
  618.     Canvas.Pen.Handle := ExtCreatePen(PS_GEOMETRIC or APenStyle or PS_ENDCAP_SQUARE, APenWidth, LB, 0, nil);
  619. end;
  620.  
  621. procedure TGmPrinterCanvas.SetActive(AValue: Boolean);
  622. begin
  623.   SetWindowOrgEx(Handle,
  624.                  FOffset.x,
  625.                  FOffset.y,
  626.                  nil);
  627.   FActive := AValue;
  628. end;
  629.  
  630. //------------------------------------------------------------------------------
  631.  
  632. // *** Public functions ***
  633.  
  634. function TGmPrinterCanvas.GraphicHeightInch(AGraphic: TGraphic): Extended;
  635. begin
  636.   Result := GraphicExtent(AGraphic).Height;
  637. end;
  638.  
  639. function TGmPrinterCanvas.GraphicWidthInch(AGraphic: TGraphic): Extended;
  640. begin
  641.   Result := GraphicExtent(AGraphic).Width;
  642. end;
  643.  
  644. function TGmPrinterCanvas.TextHeight(AText: string): integer;
  645. begin
  646.     Result := Round(TextHeightInch(AText) * PrinterPpiY);
  647. end;
  648.  
  649. function TGmPrinterCanvas.TextWidth(AText: string): integer;
  650. begin
  651.     Result := Round(TextWidthInch(AText) * PrinterPpiX);
  652. end;
  653.  
  654. function TGmPrinterCanvas.TextHeightInch(AText: string): Extended;
  655. begin
  656.   Result := TextExtent(AText).Height;
  657. end;
  658.  
  659. function TGmPrinterCanvas.TextWidthInch(AText: string): Extended;
  660. begin
  661.   Result := TextExtent(AText).Width;
  662. end;
  663.  
  664. procedure TGmPrinterCanvas.Arc(inchPoints: TGmComplexPoints);
  665. begin
  666.   if not FActive then Exit;
  667. //  ConvertColors;
  668.   SelectPen;
  669.   Windows.Arc(Handle,
  670.               InchesToPixels(ScaleValue(inchPoints[1], FPrintScale), PpiX),
  671.               InchesToPixels(ScaleValue(inchPoints[2], FPrintScale), PpiY),
  672.               InchesToPixels(ScaleValue(inchPoints[3], FPrintScale), PpiX),
  673.               InchesToPixels(ScaleValue(inchPoints[4], FPrintScale), PpiY),
  674.               InchesToPixels(ScaleValue(inchPoints[5], FPrintScale), PpiX),
  675.               InchesToPixels(ScaleValue(inchPoints[6], FPrintScale), PpiY),
  676.               InchesToPixels(ScaleValue(inchPoints[7], FPrintScale), PpiX),
  677.               InchesToPixels(ScaleValue(inchPoints[8], FPrintScale), PpiY));
  678. end;
  679.  
  680. procedure TGmPrinterCanvas.Chord(inchPoints: TGmComplexPoints);
  681. begin
  682.   if not FActive then Exit;
  683. //  ConvertColors;
  684.   SelectPen;
  685.   Windows.Chord(Handle,
  686.                 InchesToPixels(ScaleValue(inchPoints[1], FPrintScale), PpiX),
  687.                 InchesToPixels(ScaleValue(inchPoints[2], FPrintScale), PpiY),
  688.                 InchesToPixels(ScaleValue(inchPoints[3], FPrintScale), PpiX),
  689.                 InchesToPixels(ScaleValue(inchPoints[4], FPrintScale), PpiY),
  690.                 InchesToPixels(ScaleValue(inchPoints[5], FPrintScale), PpiX),
  691.                 InchesToPixels(ScaleValue(inchPoints[6], FPrintScale), PpiY),
  692.                 InchesToPixels(ScaleValue(inchPoints[7], FPrintScale), PpiX),
  693.                 InchesToPixels(ScaleValue(inchPoints[8], FPrintScale), PpiY));
  694. end;
  695.  
  696. procedure TGmPrinterCanvas.Draw(inchX, inchY: Extended; AGraphic: TGraphic);
  697. var
  698.   ARect: TGmRect;
  699. begin
  700.   ARect.Left := inchX;
  701.   ARect.Top  := inchY;
  702.   ARect.Right := ARect.Left + (AGraphic.Width div SCREEN_PPI);
  703.   ARect.Bottom := ARect.Top + (AGraphic.Height div SCREEN_PPI);
  704.   StretchDraw(ARect, AGraphic);
  705. end;
  706.  
  707. procedure TGmPrinterCanvas.Ellipse(inchX, inchY, inchX2, inchY2: Extended);
  708. begin
  709.   if not FActive then Exit;
  710. //  ConvertColors;
  711.   SelectPen;
  712.   Windows.Ellipse(Handle,
  713.                   InchesToPixels(ScaleValue(inchX, FPrintScale), PpiX),
  714.                   InchesToPixels(ScaleValue(inchY, FPrintScale), PpiY),
  715.                   InchesToPixels(ScaleValue(inchX2, FPrintScale), PpiX),
  716.                   InchesToPixels(ScaleValue(inchY2, FPrintScale), PpiY));
  717. end;
  718.  
  719. procedure TGmPrinterCanvas.MoveTo(inchX, inchY: Extended);
  720. begin
  721.   if not FActive then Exit;
  722.   FPenPos := GmPoint(inchX, inchY);
  723.   Windows.MoveToEx(Handle,
  724.                    InchesToPixels(ScaleValue(inchX, FPrintScale), PpiX),
  725.                    InchesToPixels(ScaleValue(inchY, FPrintScale), PpiY),
  726.                    nil);
  727. end;
  728.  
  729. procedure TGmPrinterCanvas.LineTo(inchX, inchY: Extended);
  730. var
  731.   Points: array[1..2] of TPoint;
  732. begin
  733.   if not FActive then Exit;
  734. //  ConvertColors;
  735.   SelectPen;
  736.   Points[1] := GmPointToPixels(ScaleGmPoint(FPenPos, FPrintScale), PpiX, PpiY);
  737.   Points[2] := GmPointToPixels(ScaleGmPoint(GmPoint(inchX, inchY), FPrintScale), PpiX, PpiY);
  738.   Windows.Polyline(Handle, Points, High(Points));
  739.   FPenPos := GmPoint(inchX, inchY);
  740. end;
  741.  
  742. procedure TGmPrinterCanvas.Pie(inchPoints: TGmComplexPoints);
  743. begin
  744.   if not FActive then Exit;
  745. //  ConvertColors;
  746.   SelectPen;
  747.   Windows.Pie(Handle,
  748.               InchesToPixels(ScaleValue(inchPoints[1], FPrintScale), PpiX),
  749.               InchesToPixels(ScaleValue(inchPoints[2], FPrintScale), PpiY),
  750.               InchesToPixels(ScaleValue(inchPoints[3], FPrintScale), PpiX),
  751.               InchesToPixels(ScaleValue(inchPoints[4], FPrintScale), PpiY),
  752.               InchesToPixels(ScaleValue(inchPoints[5], FPrintScale), PpiX),
  753.               InchesToPixels(ScaleValue(inchPoints[6], FPrintScale), PpiY),
  754.               InchesToPixels(ScaleValue(inchPoints[7], FPrintScale), PpiX),
  755.               InchesToPixels(ScaleValue(inchPoints[8], FPrintScale), PpiY));
  756. end;
  757.  
  758.  
  759. procedure TGmPrinterCanvas.Polygon(const inchPoints: array of TGmPoint);
  760. begin
  761.   PrintPolyShape(GM_POLYGON_ID, inchPoints);
  762. end;
  763.  
  764. procedure TGmPrinterCanvas.Polyline(const inchPoints: array of TGmPoint);
  765. begin
  766.   PrintPolyShape(GM_POLYLINE_ID, inchPoints);
  767. end;
  768.  
  769.  
  770. procedure TGmPrinterCanvas.PolylineTo(const inchPoints: array of TGmPoint);
  771. begin
  772.   PrintPolyShape(GM_POLYLINETO_ID, inchPoints);
  773. end;
  774.  
  775. procedure TGmPrinterCanvas.PolyBezier(const inchPoints: array of TGmPoint);
  776. begin
  777.   PrintPolyShape(GM_POLYBEZIER_ID, inchPoints);
  778. end;
  779.  
  780. procedure TGmPrinterCanvas.PolyBezierTo(const inchPoints: array of TGmPoint);
  781. begin
  782.   PrintPolyShape(GM_POLYBEZIERTO_ID, inchPoints);
  783. end;
  784.  
  785. procedure TGmPrinterCanvas.Rectangle(inchX, inchY, inchX2, inchY2: Extended);
  786. begin
  787.   if not FActive then Exit;
  788. //  ConvertColors;
  789.   SelectPen;
  790.   Windows.Rectangle(Handle,
  791.                     InchesToPixels(ScaleValue(inchX, FPrintScale), PpiX),
  792.                     InchesToPixels(ScaleValue(inchY, FPrintScale), PpiY),
  793.                     InchesToPixels(ScaleValue(inchX2, FPrintScale), PpiX),
  794.                     InchesToPixels(ScaleValue(inchY2, FPrintScale), PpiY));
  795. end;
  796.  
  797. procedure TGmPrinterCanvas.Refresh;
  798. begin
  799.   Canvas.Refresh;
  800.   SetActive(True);
  801. end;
  802.  
  803. procedure TGmPrinterCanvas.RoundRect(inchX, inchY, inchX2, inchY2, inchCornerX, inchCornerY: Extended);
  804. begin
  805.   if not FActive then Exit;
  806. //  ConvertColors;
  807.   SelectPen;
  808.   Windows.RoundRect(Handle,
  809.                     InchesToPixels(ScaleValue(inchX, FPrintScale), PpiX),
  810.                     InchesToPixels(ScaleValue(inchY, FPrintScale), PpiY),
  811.                     InchesToPixels(ScaleValue(inchX2, FPrintScale), PpiX),
  812.                     InchesToPixels(ScaleValue(inchY2, FPrintScale), PpiY),
  813.                     InchesToPixels(ScaleValue(inchCornerX, FPrintScale), PpiX),
  814.                     InchesToPixels(ScaleValue(inchCornerY, FPrintScale), PpiY));
  815. end;
  816.  
  817. procedure TGmPrinterCanvas.StretchDraw(inchRect: TGmRect; AGraphic: TGraphic);
  818. begin
  819.   if (AGraphic is TBitmap) then PrintBitmap(inchRect, (AGraphic as TBitmap));
  820.   if (AGraphic is TJPegImage) then PrintJPeg(inchRect, (AGraphic as TJPegImage));
  821.   if (AGraphic is TMetafile) then PrintMetafile(inchRect, (AGraphic as TMetafile));
  822. end;
  823.  
  824. procedure TGmPrinterCanvas.TextBoxOut(inchRect: TGmRect; Align: TAlignment; VertAlign: TGmVertAlignment; AWordBreak: Byte; AText: string);
  825. var
  826.   ARect: TRect;
  827. begin
  828.   if not FActive then Exit;
  829.   Canvas.Font.PixelsPerInch := Round(Canvas.Font.PixelsPerInch / FPrintScale);
  830.   ARect.Left    := InchesToPixels(ScaleValue(inchRect.Left, FPrintScale), PpiX);
  831.   ARect.Top     := InchesToPixels(ScaleValue(inchRect.Top, FPrintScale), PpiX);
  832.   ARect.Right   := InchesToPixels(ScaleValue(inchRect.Right, FPrintScale), PpiX);
  833.   ARect.Bottom  := InchesToPixels(ScaleValue(inchRect.Bottom, FPrintScale), PpiX);
  834.   SelectPen;
  835.   Windows.Rectangle(Handle,
  836.                     ARect.Left,
  837.                     ARect.Top,
  838.                     ARect.Right,
  839.                     ARect.Bottom);
  840.   Canvas.Brush.Style := bsClear;
  841.   Windows.DrawText(Handle,
  842.                    PChar(AText),
  843.                    Length(AText),
  844.                    ARect,
  845.                       DT_NOPREFIX+
  846.                    AWordBreak+
  847.                    ConvertAlignment(Align)+
  848.                    ConvertVertAlignment(VertAlign)+
  849.                    DT_EXPANDTABS);
  850. end;
  851.  
  852. procedure TGmPrinterCanvas.TextOut(inchX, inchY: Extended; Alignment: TAlignment; AText: string);
  853. var
  854.   x, y: integer;
  855. begin
  856.   if not FActive then Exit;
  857.  
  858.   Canvas.Font.PixelsPerInch := Round(Canvas.Font.PixelsPerInch / FPrintScale);
  859.   Canvas.Font.Assign(Canvas.Font);
  860.   if FFontAngle <> 0 then SelectFont(FPrintScale);
  861.  
  862.   x := InchesToPixels(ScaleValue(inchX, FPrintScale), PpiX);
  863.   y := InchesToPixels(ScaleValue(inchY, FPrintScale), PpiY);
  864.  
  865.   if Canvas.Font.Color <> clBlack then
  866.   begin
  867.     if (Brush.Style <> bsClear) then
  868.     begin
  869.         BeginPath;
  870.         case Alignment of
  871.           taLeftJustify : Canvas.TextOut(x, y, AText);
  872.           taCenter      : Canvas.TextOut(x-(TextWidth(AText) div 2), y, AText);
  873.           taRightJustify: Canvas.TextOut(x-TextWidth(AText), y, AText);
  874.         end;
  875.         EndPath;
  876.         FillPath;
  877.     end;
  878.     if (Canvas.Font.Color <> clWhite) then
  879.     begin
  880.         BeginPath;
  881.         SetBkMode(Canvas.Handle, TRANSPARENT);
  882.         case Alignment of
  883.           taLeftJustify : Canvas.TextOut(x, y, AText);
  884.           taCenter      : Canvas.TextOut(x-(TextWidth(AText) div 2), y, AText);
  885.           taRightJustify: Canvas.TextOut(x-TextWidth(AText), y, AText);
  886.         end;
  887.         EndPath;
  888.         FSaveBrush.Assign(Brush);
  889.         Brush.Color := Font.Color;
  890.         FillPath;
  891.         Brush.Assign(FSaveBrush);
  892.         SetBkMode(Handle, OPAQUE);
  893.     end;
  894.   end
  895.   else
  896.     case Alignment of
  897.       taLeftJustify : Canvas.TextOut(x, y, AText);
  898.       taCenter      : Canvas.TextOut(x-(Round(Canvas.TextWidth(AText)*FPrintScale) div 2), y, AText);
  899.       taRightJustify: Canvas.TextOut(x-Round(Canvas.TextWidth(AText)*FPrintScale), y, AText);
  900.     end;
  901. end;
  902.  
  903. procedure TGmPrinterCanvas.TextOutRotate(inchX, inchY, Angle: Extended; AText: string);
  904. begin
  905.   FFontAngle := Angle;
  906.   try
  907.     TextOut(inchX, inchY, taLeftJustify, AText);
  908.   finally
  909.     FFontAngle := 0;
  910.   end;
  911. end;
  912.  
  913. procedure TGmPrinterCanvas.BeginPath;
  914. begin
  915.   if not FActive then Exit;
  916.   Windows.BeginPath(Canvas.Handle);
  917. end;
  918.  
  919. procedure TGmPrinterCanvas.EndPath;
  920. begin
  921.   if not FActive then Exit;
  922.   Windows.EndPath(Canvas.Handle);
  923. end;
  924.  
  925. procedure TGmPrinterCanvas.StrokePath;
  926. begin
  927.   if not FActive then Exit;
  928.   Windows.StrokePath(Canvas.Handle);
  929. end;
  930.  
  931. procedure TGmPrinterCanvas.FillPath;
  932. begin
  933.   if not FActive then Exit;
  934.   Windows.FillPath(Canvas.Handle);
  935. end;
  936.  
  937. procedure TGmPrinterCanvas.StrokeAndFillPath;
  938. begin
  939.   if not FActive then Exit;
  940.   Windows.StrokeAndFillPath(Canvas.Handle);
  941. end;
  942.  
  943. procedure TGmPrinterCanvas.CloseFigure;
  944. begin
  945.   if not FActive then Exit;
  946.   Windows.CloseFigure(Canvas.Handle);
  947. end;
  948.  
  949. //------------------------------------------------------------------------------
  950.  
  951. // *** TGmPrinter ***
  952.  
  953. constructor TGmPrinter.Create;
  954. begin
  955.   inherited Create;
  956.   FPrinters := TStringList.Create;
  957.   FPrinterBins := TStringList.Create;
  958.   FCanvas := TGmPrinterCanvas.Create;
  959.   FTempValue := TGmValue.Create;
  960.  
  961.   //GetMem(FDevice, 80);
  962.     //G/etMem(FDriver, 80);
  963.     //GetMem(FPort, 80);
  964.  
  965.   ResetPrinter;
  966.   FDuplexType := gmSimplex;
  967.   FDitherType := gmGrayScale;
  968.   FPagesPerSheet := gmOnePage;
  969.   FPrintColor := gmColor;
  970.   FTitle := DEFAULT_TITLE;
  971.   FFileName := '';
  972.   FOrientation := poPortrait;
  973.   FPrintCopies := 1;
  974.   FPrintQuality := gmMedium;
  975.   FShowPrintDialog := True;
  976.   FReversePrintOrder := True;
  977. end;
  978.  
  979. destructor TGmPrinter.Destroy;
  980. begin
  981.   FPrinterBins.Free;
  982.   FPrinters.Free;
  983.   FCanvas.Free;
  984.   //FreeMem(FDevice, 80);
  985.   //FreeMem(FDriver, 80);
  986.   //FreeMem(FPort, 80);
  987.   if Assigned(FTempValue) then FTempValue.Free;
  988.   inherited Destroy;
  989. end;
  990.  
  991. //------------------------------------------------------------------------------
  992.  
  993. // *** Private functions ***
  994.  
  995. function TGmPrinter.GetAborted: Boolean;
  996. begin
  997.   Result := Printer.Aborted;
  998. end;
  999.  
  1000. function TGmPrinter.GetAvailableHeight: integer;
  1001. begin
  1002.   Result := GetDeviceCaps(Handle, VERTRES);
  1003. end;
  1004.  
  1005. function TGmPrinter.GetAvailableHeightGmValue: TGmValue;
  1006. begin
  1007.   Result := GetGmValue;
  1008.   if FAvailableHeight = -1 then
  1009.     FAvailableHeight := PixelsToInches(GetAvailableHeight, PrinterPpiY);
  1010.   Result.AsInches := FAvailableHeight;
  1011. end;
  1012.  
  1013. function TGmPrinter.GetAvailableWidth: integer;
  1014. begin
  1015.   Result := GetDeviceCaps(Handle, HORZRES);
  1016. end;
  1017.  
  1018. function TGmPrinter.GetAvailableWidthGmValue: TGmValue;
  1019. begin
  1020.   Result := GetGmValue;
  1021.   if FAvailableWidth = -1 then
  1022.     FAvailableWidth := PixelsToInches(GetAvailableWidth, PrinterPpiX);
  1023.   Result.AsInches := FAvailableWidth;
  1024. end;
  1025.  
  1026. function TGmPrinter.GetGmValue: TGmValue;
  1027. begin
  1028.   if not Assigned(FTempValue) then
  1029.     FTempValue := TGmValue.Create;
  1030.   Result := FTempValue;
  1031. end;
  1032.  
  1033. function TGmPrinter.GetGmValueRect: TGmValueRect;
  1034. begin
  1035.   if not Assigned(FTempValueRect) then
  1036.     FTempValueRect := TGmValueRect.Create;
  1037.   Result := FTempValueRect;
  1038. end;
  1039.  
  1040. function TGmPrinter.GetHandle: THandle;
  1041. begin
  1042.   if PrinterSelected then
  1043.     Result := Printer.Handle
  1044.   else
  1045.     Result := 0;
  1046. end;
  1047.  
  1048. function TGmPrinter.GetIndexOf(const APrinter: string): integer;
  1049. begin
  1050.   Result := FPrinters.IndexOf(APrinter);
  1051. end;
  1052.  
  1053. function TGmPrinter.GetIsColorPrinter: Boolean;
  1054. begin
  1055.   Result := False;
  1056.   LockPrinter;
  1057.   try
  1058.     if ((DevMode^.dmFields and dm_Color) = dm_Color) then Result := True;
  1059.   finally
  1060.     UnlockPrinter;
  1061.   end;
  1062. end;
  1063.  
  1064. function TGmPrinter.GetMarginsInch: TGmRect;
  1065. begin
  1066.   Result.Left   := GetOffsetInchXY.x;
  1067.   Result.Top    := GetOffsetInchXY.y;
  1068.   Result.Right  := (PrinterWidth.AsInches - AvailableWidth.AsInches) - Result.Left;
  1069.   Result.Bottom := (PrinterHeight.AsInches - AvailableHeight.AsInches) - Result.Top;
  1070. end;
  1071.  
  1072. function TGmPrinter.GetOffset: TPoint;
  1073. begin
  1074.   Result.x := GetPixelOffsetX;
  1075.   Result.y := GetPixelOffsetY;
  1076. end;
  1077.  
  1078. function TGmPrinter.GetPixelOffsetX: integer;
  1079. begin
  1080.   if FOffset.x = -1 then
  1081.   begin
  1082.     Result := GetDeviceCaps(Handle, PHYSICALOFFSETX);
  1083.     FOffset.x := Result;
  1084.   end
  1085.   else
  1086.     Result := FOffset.x;
  1087. end;
  1088.  
  1089. function TGmPrinter.GetPixelOffsetY: integer;
  1090. begin
  1091.   if FOffset.y = -1 then
  1092.   begin
  1093.     Result := GetDeviceCaps(Handle, PHYSICALOFFSETY);
  1094.     FOffset.y := Result;
  1095.   end
  1096.   else
  1097.     Result := FOffset.y;
  1098. end;
  1099.  
  1100. function TGmPrinter.GetOffsetInchXY: TGmPoint;
  1101. begin
  1102.   Result.x := PixelsToInches(GetPixelOffsetX, PrinterPpiX);
  1103.   Result.y := PixelsToInches(GetPixelOffsetY, PrinterPpiY);
  1104. end;
  1105.  
  1106. function TGmPrinter.GetOrientation: TPrinterOrientation;
  1107. begin
  1108.   if Printer.Printing then
  1109.   begin
  1110.     Result := FOrientation;
  1111.     Exit;
  1112.   end
  1113.   else
  1114.     Result := Printer.Orientation;
  1115. end;
  1116.  
  1117. function TGmPrinter.GetPageHeight: integer;
  1118. begin
  1119.   Result := GetDeviceCaps(Handle, PHYSICALHEIGHT);
  1120. end;
  1121.  
  1122. function TGmPrinter.GetPageWidth: integer;
  1123. begin
  1124.    Result := GetDeviceCaps(Handle, PHYSICALWIDTH);
  1125. end;
  1126.  
  1127. {function TGmPrinter.GetPageHeightInch: Extended;
  1128. begin
  1129.   if FPageHeight = -1 then
  1130.   begin
  1131.     Result := PixelsToInches(GetPageHeight, PrinterPpiY);
  1132.     FPageHeight := Result;
  1133.   end
  1134.   else
  1135.     Result := FPageHeight;
  1136. end;
  1137.        }
  1138. {function TGmPrinter.GetPageWidthInch: Extended;
  1139. begin
  1140.   if FPageWidth = -1 then
  1141.   begin
  1142.     Result := PixelsToInches(GetPageWidth, PrinterPpiX);
  1143.     FPageWidth := Result;
  1144.   end
  1145.   else
  1146.     Result := FPageWidth;
  1147. end; }
  1148.  
  1149. function TGmPrinter.GetPageHeightGmValue: TGmValue;
  1150. begin
  1151.   Result := GetGmValue;
  1152.   if FPageHeight = -1 then
  1153.     FPageHeight := PixelsToInches(GetPageHeight, PrinterPpiX);
  1154.   Result.AsInches := FPageHeight;
  1155. end;
  1156.  
  1157. function TGmPrinter.GetPageWidthGmValue: TGmValue;
  1158. begin
  1159.   Result := GetGmValue;
  1160.   if FPageWidth = -1 then
  1161.     FPageWidth := PixelsToInches(GetPageWidth, PrinterPpiX);
  1162.   Result.AsInches := FPageWidth;
  1163. end;
  1164.  
  1165. function TGmPrinter.GetPaperSize: TGmPaperSize;
  1166. begin
  1167.   LockPrinter;
  1168.   try
  1169.     if DevMode <> nil then Result :=  AsGmPaperSize(DevMode^.dmPaperSize)
  1170.     else Result := Custom;
  1171.   finally
  1172.     UnlockPrinter;
  1173.   end;
  1174. end;
  1175.  
  1176. function TGmPrinter.GetPpiX: integer;
  1177. begin
  1178.   if FPpiX = -1 then
  1179.   begin
  1180.     Result := GetDeviceCaps(Handle, LOGPIXELSX);
  1181.     FCanvas.FPpiX := Result;
  1182.   end
  1183.   else
  1184.     Result := FPpiX;
  1185. end;
  1186.  
  1187. function TGmPrinter.GetPpiY: integer;
  1188. begin
  1189.   if FPpiY = -1 then
  1190.   begin
  1191.     Result := GetDeviceCaps(Handle, LOGPIXELSY);
  1192.     FCanvas.FPpiY := Result;
  1193.   end
  1194.   else
  1195.     Result := FPpiX;
  1196. end;
  1197.  
  1198. function TGmPrinter.GetPrinterBinIndex: integer;
  1199. begin
  1200.   // get the current printer bin index of the selected printer...
  1201.   LockPrinter;
  1202.   try
  1203.     Result := DevMode^.dmDefaultSource;
  1204.   finally
  1205.     UnlockPrinter;
  1206.   end;
  1207. end;
  1208.  
  1209. function TGmPrinter.GetPrinterBins: TStrings;
  1210. var
  1211.   ICount: integer;
  1212.   ABin : array[0..255] of Char;
  1213. begin
  1214.   LockPrinter;
  1215.   try
  1216.     FPrinterBins.Clear;
  1217.     for ICount := 1 to DeviceCapabilities(FDevice,FPort,DC_BINNAMES,ABin,nil) do
  1218.       FPrinterBins.Add(ABin+24*(ICount-1));
  1219.   finally
  1220.     UnlockPrinter;
  1221.     Result := FPrinterBins;
  1222.   end;
  1223. end;
  1224.  
  1225. function TGmPrinter.GetPrinterIndex: integer;
  1226. begin
  1227.   if PrinterSelected then
  1228.     Result := Printer.PrinterIndex
  1229.   else
  1230.     Result := -1;
  1231. end;
  1232.  
  1233. function TGmPrinter.GetPrinterMargins: TGmValueRect;
  1234. var
  1235.   ARect: TGmRect;
  1236. begin
  1237.   Result := GetGmValueRect;
  1238.   ARect := GetMarginsInch;
  1239.  /// Result.Left.AsPixels[600] := GetPixelOffsetX;
  1240.  // Result.Top.AsPixels[600] := GetPixelOffsetY;
  1241.  // Result.Right.AsPixels[600] := (GetPageWidth-GetPixelOffsetX)-GetAvailableWidth;
  1242.  // Result.Bottom.AsPixels[600] := (GetPageHeight-GetPixelOffsetY)-GetAvailableHeight;
  1243.   Result.Left.AsInches := ARect.Left;
  1244.   Result.Top.AsInches := ARect.Top;
  1245.   Result.Right.AsInches := ARect.Right;
  1246.   Result.Bottom.AsInches := ARect.Bottom;
  1247. end;
  1248.  
  1249. procedure TGmPrinter.PrintToFile(AFileName: string);
  1250. var
  1251.   CTitle: array[0..31] of Char;
  1252.   DocInfo: TDocInfo;
  1253. begin
  1254.   with Printer do
  1255.   begin
  1256.     BeginDoc;
  1257.     { Abort job just started on API level. }
  1258.     EndPage( Canvas.handle );
  1259.     Windows.AbortDoc( Canvas.handle );
  1260.     { Restart it with a print file as destination. }
  1261.     StrPLCopy(CTitle, FTitle, SizeOf(CTitle) - 1);
  1262.     FillChar(DocInfo, SizeOf(DocInfo), 0);
  1263.     with DocInfo do
  1264.     begin
  1265.       cbSize := SizeOf(DocInfo);
  1266.       lpszDocName := CTitle;
  1267.       lpszOutput := PChar(FFileName);
  1268.     end;
  1269.     StartDoc(Canvas.handle, DocInfo);
  1270.     StartPage(Canvas.handle);
  1271.   end;
  1272. end;
  1273.  
  1274. function TGmPrinter.GetPrinters: TStrings;
  1275. begin
  1276.   Result := Printer.Printers;
  1277. end;
  1278.  
  1279. function TGmPrinter.GetPrinterSelected: Boolean;
  1280. begin
  1281.   Result := Printer.Printers.Count > 0;
  1282. end;
  1283.  
  1284. procedure TGmPrinter.LockPrinter;
  1285. begin
  1286.   ResetPrinter;
  1287.   // Reload the printer DEVMODE structure...
  1288.   //ReloadDevMode;
  1289.   DevMode := GlobalLock(DeviceMode);
  1290. end;
  1291.  
  1292. procedure TGmPrinter.OffsetCanvas;
  1293. begin
  1294.   FCanvas.Refresh;
  1295.   if FPagesPerSheet = gmTwoPage then
  1296.   begin
  1297.     if Printer.Orientation = poLandscape then
  1298.     begin
  1299.       case (FPageCount mod 2) of
  1300.         0: SetWindowOrgEx(Canvas.Handle, FOffset.x, FOffset.y, nil);
  1301.         1: SetWindowOrgEx(Canvas.Handle, FOffset.x + (0-(GetPageWidth div 2)), FOffset.y, nil);
  1302.       end
  1303.     end
  1304.     else
  1305.     begin
  1306.       case (FPageCount mod 2) of
  1307.         0: SetWindowOrgEx(Canvas.Handle, FOffset.x, FOffset.y, nil);
  1308.         1: SetWindowOrgEx(Canvas.Handle, FOffset.x, FOffset.y + (GetPageHeight div 2), nil);
  1309.       end;
  1310.     end;
  1311.   end;
  1312.   if FPagesPerSheet = gmFourPage then
  1313.   begin
  1314.     case (FPageCount mod 4) of
  1315.       0: SetWindowOrgEx(Canvas.Handle, FOffset.x, FOffset.y, nil);
  1316.       1: SetWindowOrgEx(Canvas.Handle, FOffset.x + (0-(GetPageWidth div 2)), FOffset.y, nil);
  1317.       2: SetWindowOrgEx(Canvas.Handle, FOffset.x, FOffset.y + (0-(GetPageHeight div 2)), nil);
  1318.       3: SetWindowOrgEx(Canvas.Handle, FOffset.x + (0-(GetPageWidth div 2)), FOffset.y + (0-(GetPageHeight div 2)), nil);
  1319.     end;
  1320.   end;
  1321. end;
  1322.  
  1323. procedure TGmPrinter.ResetPrinter;
  1324. begin
  1325.   // reset the printer...
  1326.   //ReloadDevMode;
  1327.   Printer.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
  1328.   Printer.SetPrinter(FDevice, FDriver, FPort, 0);
  1329.   FOffset := Point(-1, -1);
  1330.   FAvailableWidth := -1;
  1331.   FAvailableHeight := -1;
  1332.   FPageHeight := -1;
  1333.   FPageWidth := -1;
  1334.   FPpiX := -1;
  1335.   FPpiY := -1;
  1336.   FPrintCopies := 1;
  1337. end;
  1338.  
  1339. procedure TGmPrinter.SetDitherType(const AValue: TGmDitherType);
  1340. begin
  1341.   LockPrinter;
  1342.   try
  1343.     if DevMode <> nil then
  1344.     begin
  1345.       case AValue of
  1346.         gmNone      : DevMode^.dmDitherType := DMDITHER_NONE;
  1347.         gmCourse    : DevMode^.dmDitherType := DMDITHER_COARSE;
  1348.         gmFine      : DevMode^.dmDitherType := DMDITHER_FINE;
  1349.         gmLineArt   : DevMode^.dmDitherType := DMDITHER_LINEART;
  1350.         gmGrayScale : DevMode^.dmDitherType := DMDITHER_GRAYSCALE;
  1351.       end;
  1352.     end;
  1353.   finally
  1354.     UnlockPrinter;
  1355.   end;
  1356. end;
  1357.  
  1358. procedure TGmPrinter.SetDuplexType(const AValue: TGmDuplexType);
  1359. begin
  1360.   // set the printer duplex printing option...
  1361.   LockPrinter;
  1362.   try
  1363.     if DevMode <> nil then
  1364.     begin
  1365.       case AValue of
  1366.         gmSimplex     : DevMode^.dmDuplex := DMDUP_SIMPLEX;
  1367.         gmHorzDuplex  : DevMode^.dmDuplex := DMDUP_HORIZONTAL;
  1368.         gmVertDuplex  : DevMode^.dmDuplex := DMDUP_VERTICAL;
  1369.       end;
  1370.     end;
  1371.   finally
  1372.     UnlockPrinter;
  1373.   end;
  1374. end;
  1375.  
  1376. procedure TGmPrinter.SetOrientation(AOrientation: TPrinterOrientation);
  1377. const
  1378.   Orientations: array [TPrinterOrientation] of Integer = (
  1379.     DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
  1380. begin
  1381.   LockPrinter;
  1382.   try
  1383.     if ((DevMode^.dmFields and DM_ORIENTATION) = DM_ORIENTATION) then
  1384.       DevMode^.dmOrientation := Orientations[AOrientation];
  1385.   finally
  1386.     FOrientation := AOrientation;
  1387.     UnlockPrinter;
  1388.   end;
  1389. end;
  1390.  
  1391. procedure TGmPrinter.SetPaperSize(APaperSize: TGmPaperSize);
  1392. var
  1393.   ASize: SmallInt;
  1394. begin
  1395.   ASize := AsPrinterPaperSize(APaperSize);
  1396.   if ASize = -1 then Exit;
  1397.   LockPrinter;
  1398.   try
  1399.     if DevMode <> nil then DevMode^.dmPaperSize := ASize;
  1400.   finally
  1401.     UnlockPrinter;
  1402.   end;
  1403. end;
  1404.  
  1405. procedure TGmPrinter.SetPrintColor(AColor: TGmPrintColor);
  1406. begin
  1407.   LockPrinter;
  1408.   try
  1409.     if DevMode <> nil then
  1410.     begin
  1411.       FPrintColor := gmMonochrome;
  1412.       DevMode^.dmColor := DMCOLOR_MONOCHROME;
  1413.       if AColor = gmColor then
  1414.       begin
  1415.         if (DevMode^.dmFields and dm_Color) = DM_COLOR then
  1416.         begin
  1417.           DevMode^.dmColor := DMCOLOR_COLOR;
  1418.           FPrintColor := gmColor;
  1419.         end;
  1420.       end;
  1421.     end;
  1422.   finally
  1423.     UnlockPrinter;
  1424.   end;
  1425. end;
  1426.  
  1427. procedure TGmPrinter.SetPrintDialog(const ADialog: TPrintDialog);
  1428. begin
  1429.   FPrintDialog := ADialog;
  1430. end;
  1431.  
  1432. procedure TGmPrinter.SetPrinterBinIndex(const AValue: integer);
  1433. begin
  1434.   LockPrinter;
  1435.   try
  1436.     if DevMode <> nil then DevMode^.dmDefaultSource := AValue;
  1437.   finally
  1438.     UnlockPrinter;
  1439.   end;
  1440. end;
  1441.  
  1442. procedure TGmPrinter.SetPrinterIndex(const AValue: integer);
  1443. begin
  1444.   if Printer.PrinterIndex <> AValue then
  1445.   begin
  1446.     Printer.PrinterIndex := AValue;
  1447.     ResetPrinter;
  1448.     PrinterChanged(Self);
  1449.   end;
  1450. end;
  1451.  
  1452. procedure TGmPrinter.SetPrintQuality(const AValue: TGmPrintQuality);
  1453. begin
  1454.   LockPrinter;
  1455.   try
  1456.     if (DevMode^.dmFields and dm_printquality) = dm_printquality then
  1457.     begin
  1458.       case AValue of
  1459.         gmDraft : DevMode^.dmPrintQuality := Short(DMRES_DRAFT);
  1460.         gmLow   : DevMode^.dmPrintQuality := Short(DMRES_LOW);
  1461.         gmMedium: DevMode^.dmPrintQuality := Short(DMRES_MEDIUM);
  1462.         gmHigh  : DevMode^.dmPrintQuality := Short(DMRES_HIGH);
  1463.       end;
  1464.       FPrintQuality := AValue;
  1465.     end;
  1466.   finally
  1467.     UnlockPrinter;
  1468.   end;
  1469. end;
  1470.  
  1471. procedure TGmPrinter.SetTitle(const ATitle: string);
  1472. begin
  1473.   if FTitle <> ATitle then
  1474.     FTitle := ATitle;
  1475. end;
  1476.  
  1477. procedure TGmPrinter.SwapOrientation;
  1478. begin
  1479.   with Printer do
  1480.   begin
  1481.     if Orientation = poPortrait then Orientation := poLandscape
  1482.     else Orientation := poPortrait;
  1483.   end;
  1484. end;
  1485.  
  1486. procedure TGmPrinter.UnlockPrinter;
  1487. begin
  1488.   GlobalUnlock(DeviceMode);
  1489. end;
  1490.  
  1491. procedure TGmPrinter.PrinterChanged(Sender: TObject);
  1492. begin
  1493.   if Assigned(FOnPrinterChanged) then FOnPrinterChanged(Self);
  1494. end;
  1495.  
  1496. //------------------------------------------------------------------------------
  1497.  
  1498. // *** Public functions ***
  1499.  
  1500. procedure TGmPrinter.Abort;
  1501. begin
  1502.   // Aborts the print job during printing...
  1503.   if (FPrinting) then
  1504.   begin
  1505.     Printer.Abort;
  1506.     FPrinting := False;
  1507.   end;
  1508. end;
  1509.  
  1510. procedure TGmPrinter.Assign(Source: TPersistent);
  1511. var
  1512.   APrinter: TGmPrinter;
  1513. begin
  1514.   APrinter := (Source as TGmPrinter);
  1515.   FPagesPerSheet := APrinter.FPagesPerSheet;
  1516.   FPrintColor := APrinter.FPrintColor;
  1517. end;
  1518.  
  1519. procedure TGmPrinter.BeginDoc;
  1520. var
  1521.   Ph, Pw: integer;
  1522. begin
  1523.   ResetPrinter;
  1524.     SetDitherType(FDitherType);
  1525.   SetDuplexType(FDuplexType);
  1526.   SetPrintQuality(FPrintQuality);
  1527.   SetPrintColor(FPrintColor);
  1528.   SetOrientation(FOrientation);
  1529.  
  1530.   if (Assigned(FPrintDialog)) and (FShowPrintDialog) then
  1531.     if not FPrintDialog.Execute then Exit;
  1532.  
  1533.   Ph := GetPageHeight;
  1534.   Pw := GetPageWidth;
  1535.   case FPagesPerSheet of
  1536.     gmOnePage : Canvas.FPrintScale := 1;
  1537.     gmTwoPage : Canvas.FPrintScale := Min(Ph, Pw) / Max(Ph, Pw);
  1538.     gmFourPage: Canvas.FPrintScale := 0.5;
  1539.   end;
  1540.  
  1541.   FOrientationSwapped := False;
  1542.   if FPagesPerSheet = gmTwoPage then
  1543.   begin
  1544.     SwapOrientation;
  1545.     FOrientationSwapped := True;
  1546.   end;
  1547.   FPageCount := 0;
  1548.   Printer.Title := Title;
  1549.  
  1550.   if FFileName <> '' then PrintToFile(FFileName)
  1551.   else
  1552.     Printer.BeginDoc;
  1553.   FCanvas.FPrinterCanvas := Printer.Canvas;
  1554.   FCanvas.FPpiX := PrinterPpiX;
  1555.   FCanvas.FPpiY := PrinterPpiY;
  1556.   FCanvas.FOffset.x := GetPixelOffsetX;
  1557.   FCanvas.FOffset.y := GetPixelOffsetY;
  1558.   FCanvas.FPrintColor := FPrintColor;
  1559.   FCanvas.SetActive(True);
  1560.   FPrinting := True;
  1561. end;
  1562.  
  1563. procedure TGmPrinter.EndDoc;
  1564. begin
  1565.   FCanvas.SetActive(False);
  1566.  
  1567.   Printer.EndDoc;
  1568.   if FOrientationSwapped then SwapOrientation;
  1569.   FPrinting  := False;
  1570. end;
  1571.  
  1572. {  hDeviceMode: THandle;
  1573.   pDevMode: PDeviceMode;
  1574. begin
  1575.  
  1576. end;    }
  1577.  
  1578. procedure TGmPrinter.NewPage(AOrientation: TGmOrientation);
  1579.  
  1580.   procedure NewPage(AOrientation: TGmOrientation);
  1581.   var
  1582.     Device, Driver, Port: array[0..80] of char;
  1583.     hDeviceMode: THandle;
  1584.     pDevMode: PDeviceMode;
  1585.   begin
  1586.     // start a new printer page of the desired orientation...
  1587.     Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  1588.     pDevMode := GlobalLock( hDevicemode );
  1589.     with pDevMode^ do
  1590.     begin
  1591.       dmFields := dmFields or DM_ORIENTATION;
  1592.       case AOrientation of
  1593.         gmPortrait  : dmOrientation := DMORIENT_PORTRAIT;
  1594.         gmLandscape : dmOrientation := DMORIENT_LANDSCAPE;
  1595.       end;
  1596.     end;
  1597.     Windows.EndPage(GetHandle);
  1598.     ResetDC(Handle, pDevMode^);
  1599.     GlobalUnlock(hDeviceMode);
  1600.     Windows.StartPage(GetHandle);
  1601.     FCanvas.Canvas.Refresh;
  1602.   end;
  1603.  
  1604. var
  1605.   AddPage: Boolean;
  1606. begin
  1607.   Inc(FPageCount);
  1608.   AddPage := False;
  1609.   if (FPagesPerSheet = gmOnePage) then AddPage := True;
  1610.   if (FPagesPerSheet = gmTwoPage) and (FPageCount mod 2 = 0) then AddPage := True;
  1611.   if (FPagesPerSheet = gmFourPage) and (FPageCount mod 4 = 0) then AddPage := True;
  1612.   if AddPage then
  1613.   begin
  1614.     if AOrientation = AsGmOrientation(Orientation) then
  1615.       Printer.NewPage
  1616.     else
  1617.       NewPage(AOrientation);
  1618.   end;
  1619.  
  1620.   OffsetCanvas;
  1621. end;
  1622.  
  1623. procedure TGmPrinter.RefreshPrinters;
  1624. begin
  1625.   // refresh the list of printers...
  1626.   FPrinters.Clear;
  1627.   FPrinters.Assign(GetPrinters);
  1628. end;
  1629.  
  1630.  
  1631. end.
  1632.